home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / scripts / snarf-check-and-output-texi < prev    next >
Encoding:
Text File  |  2004-01-06  |  10.0 KB  |  314 lines
  1. #!/bin/sh
  2. # aside from this initial boilerplate, this is actually -*- scheme -*- code
  3. main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)"
  4. exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
  5. !#
  6. ;;; snarf-check-and-output-texi --- called by the doc snarfer.
  7.  
  8. ;;     Copyright (C) 2001 Free Software Foundation, Inc.
  9. ;;
  10. ;; This program is free software; you can redistribute it and/or
  11. ;; modify it under the terms of the GNU General Public License as
  12. ;; published by the Free Software Foundation; either version 2, or
  13. ;; (at your option) any later version.
  14. ;;
  15. ;; This program is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19. ;;
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with this software; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  23. ;; Boston, MA 02111-1307 USA
  24.  
  25. ;;; Author: Michael Livshin
  26.  
  27. ;;; Code:
  28.  
  29. (define-module (scripts snarf-check-and-output-texi)
  30.     :use-module (ice-9 streams)
  31.     :use-module (ice-9 match)
  32.     :export (snarf-check-and-output-texi))
  33.  
  34. ;;; why aren't these in some module?
  35.  
  36. (define-macro (when cond . body)
  37.   `(if ,cond (begin ,@body)))
  38.  
  39. (define-macro (unless cond . body)
  40.   `(if (not ,cond) (begin ,@body)))
  41.  
  42. (define *manual-flag* #f)
  43.  
  44. (define (snarf-check-and-output-texi . flags)
  45.   (if (member "--manual" flags)
  46.       (set! *manual-flag* #t))
  47.   (process-stream (current-input-port)))
  48.  
  49. (define (process-stream port)
  50.   (let loop ((input (stream-map (match-lambda
  51.                                  (('id . s)
  52.                                   (cons 'id (string->symbol s)))
  53.                                  (('int_dec . s)
  54.                                   (cons 'int (string->number s)))
  55.                                  (('int_oct . s)
  56.                                   (cons 'int (string->number s 8)))
  57.                                  (('int_hex . s)
  58.                                   (cons 'int (string->number s 16)))
  59.                                  ((and x (? symbol?))
  60.                                   (cons x x))
  61.                                  ((and x (? string?))
  62.                                   (cons 'string x))
  63.                                  (x x))
  64.                                 (make-stream (lambda (s)
  65.                                                (let loop ((s s))
  66.                                                  (cond
  67.                                                    ((stream-null? s) #t)
  68.                                                    ((eq? 'eol (stream-car s))
  69.                                                     (loop (stream-cdr s)))
  70.                                                    (else (cons (stream-car s) (stream-cdr s))))))
  71.                                              (port->stream port read)))))
  72.  
  73.     (unless (stream-null? input)
  74.       (let ((token (stream-car input)))
  75.         (if (eq? (car token) 'snarf_cookie)
  76.           (dispatch-top-cookie (stream-cdr input)
  77.                                loop)
  78.           (loop (stream-cdr input)))))))
  79.  
  80. (define (dispatch-top-cookie input cont)
  81.  
  82.   (when (stream-null? input)
  83.     (error 'syntax "premature end of file"))
  84.  
  85.   (let ((token (stream-car input)))
  86.     (cond
  87.       ((eq? (car token) 'brace_open)
  88.        (consume-multiline (stream-cdr input)
  89.                           cont))
  90.       (else
  91.        (consume-upto-cookie process-singleline
  92.                             input
  93.                             cont)))))
  94.  
  95. (define (consume-upto-cookie process input cont)
  96.   (let loop ((acc '()) (input input))
  97.  
  98.     (when (stream-null? input)
  99.       (error 'syntax "premature end of file in directive context"))
  100.  
  101.     (let ((token (stream-car input)))
  102.       (cond
  103.         ((eq? (car token) 'snarf_cookie)
  104.          (process (reverse! acc))
  105.          (cont (stream-cdr input)))
  106.  
  107.         (else (loop (cons token acc) (stream-cdr input)))))))
  108.  
  109. (define (consume-multiline input cont)
  110.   (begin-multiline)
  111.  
  112.   (let loop ((input input))
  113.  
  114.     (when (stream-null? input)
  115.       (error 'syntax "premature end of file in multiline context"))
  116.  
  117.     (let ((token (stream-car input)))
  118.       (cond
  119.         ((eq? (car token) 'brace_close)
  120.          (end-multiline)
  121.          (cont (stream-cdr input)))
  122.  
  123.         (else (consume-upto-cookie process-multiline-directive
  124.                                    input
  125.                                    loop))))))
  126.  
  127. (define *file* #f)
  128. (define *line* #f)
  129. (define *c-function-name* #f)
  130. (define *function-name* #f)
  131. (define *snarf-type* #f)
  132. (define *args* #f)
  133. (define *sig* #f)
  134. (define *docstring* #f)
  135.  
  136. (define (begin-multiline)
  137.   (set! *file* #f)
  138.   (set! *line* #f)
  139.   (set! *c-function-name* #f)
  140.   (set! *function-name* #f)
  141.   (set! *snarf-type* #f)
  142.   (set! *args* #f)
  143.   (set! *sig* #f)
  144.   (set! *docstring* #f))
  145.  
  146. (define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
  147. (define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
  148.  
  149. (define (end-multiline)
  150.   (let* ((req (car *sig*))
  151.          (opt (cadr *sig*))
  152.          (var (caddr *sig*))
  153.          (all (+ req opt var)))
  154.     (if (and (not (eqv? *snarf-type* 'register))
  155.              (not (= (length *args*) all)))
  156.       (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
  157.              *file* *line* name (length *args*) all)))
  158.     (let ((nice-sig
  159.             (if (eq? *snarf-type* 'register)
  160.               *function-name*
  161.               (with-output-to-string
  162.                 (lambda ()
  163.                   (format #t "~A" *function-name*)
  164.                   (let loop-req ((args *args*) (r 0))
  165.                     (if (< r req)
  166.                       (begin
  167.                        (format #t " ~A" (car args))
  168.                        (loop-req (cdr args) (+ 1 r)))
  169.                       (let loop-opt ((o 0) (args args) (tail '()))
  170.                        (if (< o opt)
  171.                          (begin
  172.                           (format #t " [~A" (car args))
  173.                           (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
  174.                          (begin
  175.                           (if (> var 0)
  176.                             (format #t " . ~A"
  177.                                     (car args)))
  178.                           (let loop-tail ((tail tail))
  179.                                (if (not (null? tail))
  180.                                  (begin
  181.                                   (format #t "~A" (car tail))
  182.                                   (loop-tail (cdr tail))))))))))))))
  183.       (scm-deffnx
  184.         (if (and *manual-flag* (eq? *snarf-type* 'primitive))
  185.         (with-output-to-string
  186.           (lambda ()
  187.                     (format #t "@deffnx {C Function} ~A (" *c-function-name*)
  188.             (unless (null? *args*)
  189.               (format #t "~A" (car *args*))
  190.               (let loop ((args (cdr *args*)))
  191.             (unless (null? args)
  192.               (format #t ", ~A" (car args))
  193.               (loop (cdr args)))))
  194.             (format #t ")\n")))
  195.         #f)))
  196.       (format #t "\n ~A\n" *function-name*)
  197.       (format #t "@c snarfed from ~A:~A\n" *file* *line*)
  198.       (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
  199.       (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
  200.     (cond ((null? strings))
  201.           ((or (not scm-deffnx)
  202.            (and (>= (string-length (car strings))
  203.                 *primitive-deffnx-sig-length*)
  204.             (string=? (substring (car strings)
  205.                          0 *primitive-deffnx-sig-length*)
  206.                   *primitive-deffnx-signature*)))
  207.            (display (car strings))
  208.            (loop (cdr strings) scm-deffnx))
  209.           (else (display scm-deffnx)
  210.             (loop strings #f))))
  211.       (display "\n")
  212.       (display "@end deffn\n"))))
  213.  
  214. (define (texi-quote s)
  215.   (let rec ((i 0))
  216.     (if (= i (string-length s))
  217.       ""
  218.       (string-append (let ((ss (substring s i (+ i 1))))
  219.                        (if (string=? ss "@")
  220.                          "@@"
  221.                          ss))
  222.                      (rec (+ i 1))))))
  223.  
  224. (define (process-multiline-directive l)
  225.  
  226.   (define do-args
  227.     (match-lambda
  228.  
  229.      (('(paren_close . paren_close))
  230.       '())
  231.  
  232.      (('(comma . comma) rest ...)
  233.       (do-args rest))
  234.  
  235.      (('(id . SCM) ('id . name) rest ...)
  236.       (cons name (do-args rest)))
  237.  
  238.      (x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
  239.  
  240.   (define do-arglist
  241.     (match-lambda
  242.  
  243.      (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
  244.       '())
  245.  
  246.      (('(paren_open . paren_open) rest ...)
  247.       (do-args rest))
  248.  
  249.      (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
  250.  
  251.   (define do-command
  252.     (match-lambda
  253.  
  254.      (('cname ('id . name))
  255.       (set! *c-function-name* (texi-quote (symbol->string name))))
  256.  
  257.      (('fname ('string . name))
  258.       (set! *function-name* (texi-quote name)))
  259.  
  260.      (('type ('id . type))
  261.       (set! *snarf-type* type))
  262.  
  263.      (('type ('int . num))
  264.       (set! *snarf-type* num))
  265.  
  266.      (('location ('string . file) ('int . line))
  267.       (set! *file* file)
  268.       (set! *line* line))
  269.  
  270.      (('arglist rest ...)
  271.       (set! *args* (do-arglist rest)))
  272.  
  273.      (('argsig ('int . req) ('int . opt) ('int . var))
  274.       (set! *sig* (list req opt var)))
  275.  
  276.      (x (error (format #f "unknown doc attribute: ~A" x)))))
  277.  
  278.   (define do-directive
  279.     (match-lambda
  280.  
  281.      ((('id . command) rest ...)
  282.       (do-command (cons command rest)))
  283.  
  284.      ((('string . string) ...)
  285.       (set! *docstring* string))
  286.  
  287.      (x (error (format #f "unknown doc attribute syntax: ~A" x)))))
  288.  
  289.   (do-directive l))
  290.  
  291. (define (process-singleline l)
  292.  
  293.   (define do-argpos
  294.     (match-lambda
  295.      ((('id . name) ('int . pos) ('int . line))
  296.       (let ((idx (list-index *args* name)))
  297.         (when idx
  298.           (unless (= (+ idx 1) pos)
  299.             (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
  300.                              *file* line name pos (+ idx 1))
  301.                      (current-error-port))))))
  302.      (x #f)))
  303.  
  304.   (define do-command
  305.     (match-lambda
  306.      (('(id . argpos) rest ...)
  307.       (do-argpos rest))
  308.      (x (error (format #f "unknown check: ~A" x)))))
  309.  
  310.   (when *function-name*
  311.     (do-command l)))
  312.  
  313. (define main snarf-check-and-output-texi)
  314.